home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / sorts.com / SORTS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-09-22  |  8.0 KB  |  214 lines
  1. unit Sorts;      {John Haluska  CIS 74000,1106}      {Turbo Pascal 5.0, 5.5}
  2.  
  3. {$A+,B-,D+,E-,F-,I+,L+,N-,R-,S-,V-}
  4.  
  5. { Ver 1.0  9/22/90  Released to the public domain }
  6.  
  7. { Sorts contains a general purpose engine to sort in-memory static or dynamic
  8.   (heap) arrays of any type using the QuickSort algorithm.  The user must
  9.   define a compare function for the sort criteria.  Then call the sort
  10.   procedure with the array address, sort range (first/last elements), number
  11.   of bytes in each element, and compare function name.  Refer to examples at
  12.   the end of this unit for typical use.  }
  13.  
  14. interface
  15.  
  16. type
  17.   CmpTyp = function(var X1,X2) : boolean;     {define sort order criteria}
  18.  
  19. procedure SwapBytes(var A,B; Len : word);
  20. procedure QSort(var A; Ef,El,Es : integer; F : CmpTyp);
  21.  
  22. implementation
  23.  
  24. {----------------------------------------------------------------------------}
  25. { SwapBytes exchanges untyped variables A and B.  Len specifies the number of
  26.   bytes in A or B.  Both A and B must contain the same number of bytes.
  27.   Example:  SwapBytes(A,B,SizeOf(A))   exchanges A and B.  }
  28.  
  29. procedure SwapBytes(var A,B; Len : word);
  30.  
  31. begin
  32.   inline(
  33.     $8C/$DA/       {    MOV    DX,DS       ;Save DS in DX }
  34.     $8B/$8E/>Len/  {    MOV    CX,>Len[BP] ;Copy Len to CX }
  35.     $E3/$13/       {    JCXZ   X1          ;Quit if Len = 0 }
  36.     $C5/$B6/>A/    {    LDS    SI,>A[BP]   ;Load A addr }
  37.     $C4/$BE/>B/    {    LES    DI,>B[BP]   ;Load B addr }
  38.     $FC/           {    CLD                ;Set string ops to forward }
  39.     $8A/$04/       {X2: MOV    AL,[SI]     ;Read A }
  40.     $8A/$25/       {    MOV    AH,[DI]     ;Read B }
  41.     $88/$24/       {    MOV    [SI],AH     ;Write A in B addr }
  42.     $AA/           {    STOSB              ;Write B in A addr, incr B addr}
  43.     $46/           {    INC    SI          ;Increment A addr }
  44.     $E2/$F6/       {    LOOP   X2          ;Repeat }
  45.     $8E/$DA)       {X1: MOV    DS,DX       ;Restore DS }
  46. end;  {SwapBytes}
  47. {----------------------------------------------------------------------------}
  48. { QSort sorts, using the Quicksort algorithm, items in A, the address of an
  49.   in-memory static or dynamic (heap) array from start element Ef to last
  50.   element El according to user supplied compare function F.  Es is the number
  51.   of bytes in each array element.  F is Comp(var X1,X2) : boolean.  The array
  52.   will sort in ascending order if X1 < X2 and Comp returns true.  The array
  53.   index must start at 0.  The Turbo Pascal structure limit requires that
  54.   (El+1)*Es <= 65521 bytes.  Consequently up to 32760 words/integers or 16380
  55.   pointers/long integers can be sorted.  For static arrays, a pointer variable
  56.   must be used to provide the array address.   }
  57.  
  58. procedure QSort(var A; Ef,El,Es : integer; F : CmpTyp);
  59.  
  60. type
  61.   BufType = array[0..0] of byte;        {abstract zero based array structure}
  62. var
  63.   Buf : ^BufType absolute A;            {Buf at same addr as A}
  64.   Pivot :  ^BufType;
  65.   {--------}
  66.   procedure Sort(L,R : integer);
  67.   var
  68.     I,J : word;
  69.   begin
  70.     I := L;
  71.     J := R;
  72.     Move(Buf^[((I+J) shr 1)*Es],Pivot^,Es);  {get pivot value from mid list}
  73.     repeat
  74.       while F(Buf^[I*Es],Pivot^) do Inc(I);          {compare}
  75.       while F(Pivot^,Buf^[J*Es]) do Dec(J);          {compare}
  76.       if integer(I) <= integer(J) then
  77.         begin
  78.           SwapBytes(Buf^[I*Es],Buf^[J*Es],Es);
  79.           Inc(I);
  80.           Dec(J)
  81.         end;
  82.     until integer(I) > integer(J);
  83.     if integer(L) < integer(J) then Sort(L,J);
  84.     if integer(I) < integer(R) then Sort(I,R)
  85.   end;
  86.   {-------}
  87. begin
  88.   GetMem(Pivot,Es);                       {allocate pivot buffer}
  89.   {$S+} Sort(Ef,El); {$S-}                {sort with stack overflow checking}
  90.   FreeMem(Pivot,Es)                       {deallocate pivot buffer}
  91. end;  {QSort}
  92. {----------------------------------------------------------------------------}
  93. end.
  94. (*
  95.  { Example 1: Sort static array of integers in ascending order.}
  96.  
  97.   var
  98.     L1 : array[0..100] of integer;     {must start at 0, max size = 32760}
  99.     L1Ptr : pointer;
  100.     I : integer;
  101.  
  102.   {$F+} function Comp1(var X1,X2) : boolean;        {user supplied, far call}
  103.   begin
  104.     if integer(X1) < integer(X2) then Comp1 := true     {note reqd typecast}
  105.       else Comp1 := false
  106.   end;  {$F-}
  107.  
  108.   begin
  109.     L1[1] := 5;  L1[2] := 3;  L1[3] := 1;
  110.     L1Ptr := @L1;                                             {address of L1}
  111.     QSort(L1Ptr,1,3,SizeOf(integer),Comp1);
  112.     for I := 1 to 3 do Write(L1[I],' ');
  113.     Writeln
  114.   end.
  115.   {---------}
  116.   { Example 2: Sort dynamic array of integers in descending order.}
  117.  
  118.   type
  119.     ArrayTyp = array[0..32759] of integer; {must start at 0, max size = 32760}
  120.     L2Typ = ^ArrayTyp;
  121.   var
  122.     L2 : L2Typ;
  123.     I : integer;
  124.  
  125.   {$F+} function Comp2(var X1,X2) : boolean;        {user supplied, far call}
  126.   begin
  127.     if integer(X1) > integer(X2) then Comp2 := true     {note reqd typecast}
  128.       else Comp2 := false
  129.   end;  {$F-}
  130.  
  131.   begin
  132.     GetMem(L2,3*SizeOf(integer));                      {allocate heap memory}
  133.     L2^[0] := 5;  L2^[1] := 1;    L2^[2] := 3;
  134.     QSort(L2,0,2,SizeOf(integer),Comp2);
  135.     for I := 0 to 2 do Write(L2^[I],' ');
  136.     Writeln;
  137.     FreeMem(L2,3*SizeOf(integer))                    {deallocate heap memory}
  138.   end.
  139.  {----------}
  140.  { Example 3: Sort static array of pointers to records, according to Name, in
  141.    ascending order. }
  142.  
  143.   type
  144.     IdRec = record
  145.               Id : integer;
  146.               Name : string[20];
  147.             end;
  148.     IdRecPtr = ^IdRec;
  149.   var
  150.     L3 : array[0..100] of ^IdRec;       {structure = 101*23, must start at 0}
  151.     L3Ptr : pointer;                                {address of static array}
  152.     I : integer;
  153.  
  154.   {$F+} function Comp3(var X1,X2) : boolean;        {user supplied, far call}
  155.   begin                                                      {note type cast}
  156.     if IdRecPtr(X1)^.Name < IdRecPtr(X2)^.Name then Comp3 := true
  157.       else Comp3 := false
  158.   end;  {$F-}
  159.  
  160.   begin
  161.     New(L3[0]);                    {must allocate record 0, even if not used}
  162.     New(L3[1]);  L3[1]^.Name := 'James';
  163.     New(L3[2]);  L3[2]^.Name := 'Bill';
  164.     New(L3[3]);  L3[3]^.Name := 'Tom';
  165.     L3Ptr := @L3;                                                {addr of L3}
  166.     QSort(L3Ptr,1,3,SizeOf(L3[I]),Comp3);
  167.     for I := 1 to 3 do Write(L3[I]^.Name,'  ');
  168.     Writeln
  169.   end.
  170.   {----------}
  171.   { Example 4: Sort static array of pointers to records, by last and first
  172.     name in ascending order, using dynamic integer array as index. }
  173.  
  174.   type
  175.     NmRec = record
  176.               NameF : string[20];
  177.               NameL : string[20];
  178.             end;
  179.     NmLst = array[1..2000] of ^NmRec;                     {structure = 4*2000}
  180.     Int = array[0..2000] of integer;       {sort array index, must start at 0}
  181.   var
  182.     L4 : NmLst;                            {static array of pointers to NmRec}
  183.     L5 : ^Int;                          {pointer to dynamic array of integers}
  184.     I,LstLen : integer;
  185.  
  186.   {$F+} function Comp4(var X1,X2) : boolean;         {user supplied, far call}
  187.   begin
  188.     if L4[integer(X1)]^.NameL < L4[integer(X2)]^.NameL then    {note typecast}
  189.       Comp4 := true
  190.     else
  191.       if (L4[integer(X1)]^.NameL = L4[integer(X2)]^.NameL) and
  192.          (L4[integer(X1)]^.NameF < L4[integer(X2)]^.NameF) then
  193.         Comp4 := true
  194.       else
  195.         Comp4 := false
  196.   end;  {$F-}
  197.  
  198.   begin
  199.     New(L4[1]);    L4[1]^.NameL := 'Smith'; L4[1]^.NameF := 'John';
  200.     New(L4[2]);    L4[2]^.NameL := 'Smith'; L4[2]^.NameF := 'Jack';
  201.     New(L4[3]);    L4[3]^.NameL := 'Small'; L4[3]^.NameF := 'Joe';
  202.     New(L4[4]);    L4[4]^.NameL := 'Small'; L4[4]^.NameF := 'John';
  203.     LstLen := 4;
  204.     GetMem(L5,(LstLen+1)*SizeOf(integer));            {must include element 0}
  205.     for I := 1 to LstLen do L5^[I] := I;              {initialize index array}
  206.     QSort(L5,1,LstLen,SizeOf(integer),Comp4);
  207.     for I := 1 to LstLen do
  208.       Writeln(L4[L5^[I]]^.NameL,' ',L4[L5^[I]]^.NameF);
  209.     Writeln;
  210.     FreeMem(L5,(LstLen+1)*SizeOf(integer));
  211.     for I := 1 to LstLen do Dispose(L4[I]);
  212.   end.
  213.   *)
  214.